home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / lib / printf.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  3.5 KB  |  111 lines  |  [TEXT/MPS ]
  1. #open "exc";;
  2. #open "eq";;
  3. #open "bool";;
  4. #open "float";;
  5. #open "int";;
  6. #open "fchar";;
  7. #open "fstring";;
  8. #open "io";;
  9. #open "obj";;
  10.  
  11. let rec barf_if_more_args x =
  12.   invalid_arg "fprintf: too many arguments"
  13. ;;
  14.  
  15. let fprintf outchan format =
  16.   let rec doprn i =
  17.     if i >= string_length format then magic barf_if_more_args else
  18.       match nth_char format i with
  19.         `%` ->
  20.           let j = skip_args (succ i) in
  21.           begin match nth_char format j with
  22.             `%` ->
  23.               output_char outchan `%`;
  24.               doprn (succ j)
  25.           | `s` ->
  26.               magic(fun s ->
  27.                 if (not is_block (repr s)) or obj_tag (repr s) != 253 then
  28.                   invalid_arg "fprintf: string argument expected"
  29.                 else if j <= i+1 then
  30.                   output_string outchan s
  31.                 else begin
  32.                   let p =
  33.                     try
  34.                       int_of_string (sub_string format (i+1) (j-i-1))
  35.                     with _ ->
  36.                       invalid_arg "fprintf: bad %s format" in
  37.                   if p > 0 & string_length s < p then begin
  38.                     output_string outchan
  39.                                   (make_string (p - string_length s) ` `);
  40.                     output_string outchan s
  41.                   end else if p < 0 & string_length s < -p then begin
  42.                     output_string outchan s;
  43.                     output_string outchan
  44.                                   (make_string (-p - string_length s) ` `)
  45.                   end else
  46.                     output_string outchan s
  47.                 end;
  48.                 doprn (succ j))
  49.           | `c` ->
  50.               magic(fun c ->
  51.                 if is_block (repr c) then
  52.                   invalid_arg "fprintf: char argument expected"
  53.                 else begin
  54.                   output_char outchan c;
  55.                   doprn (succ j)
  56.                 end)
  57.           | `d` | `i` | `o` | `x` | `X` | `u` ->
  58.               magic(doint i j)
  59.           | `f` | `e` | `E` | `g` | `G` ->
  60.               magic(dofloat i j)
  61.           | `b` ->
  62.               magic(fun b ->
  63.                 if is_block (repr b) then
  64.                   output_string outchan (if b then "true" else "false")
  65.                 else
  66.                   invalid_arg "fprintf: boolean argument expected";
  67.                 doprn (succ j))
  68.           | c ->
  69.               invalid_arg ("fprintf: unknown format " ^ char_for_read c)
  70.           end
  71.       |  c  -> output_char outchan c; doprn (succ i)
  72.  
  73.   and skip_args j =
  74.     match nth_char format j with
  75.       `0` | `1` | `2` | `3` | `4` | `5` | `6` | `7` | `8` | `9` |
  76.       ` ` | `.` | `-` ->
  77.         skip_args (succ j)
  78.     | c ->
  79.         j
  80.     
  81.   and doint i j n =
  82.     if is_block (repr n) then
  83.       invalid_arg "fprintf: int argument expected"
  84.     else begin
  85.       let len = j-i in
  86.       let fmt = create_string (len+2) in
  87.       blit_string format i fmt 0 len;
  88.       set_nth_char fmt len `l`;
  89.       set_nth_char fmt (len+1) (nth_char format j);
  90.       output_string outchan (format_int fmt n);
  91.       doprn (succ j)
  92.     end
  93.  
  94.   and dofloat i j f =
  95.     if (not is_block (repr f)) or obj_tag (repr f) != 254 then
  96.       invalid_arg "fprintf: float argument expected"
  97.     else begin
  98.       output_string outchan (format_float (sub_string format i (j-i+1)) f);
  99.       doprn (succ j)
  100.     end
  101.  
  102.   in doprn 0
  103. ;;
  104.  
  105. let printf fmt = fprintf std_out fmt    (* Don't eta-reduce: this confuses *)
  106. ;;                                      (* the intelligent linker *)
  107.  
  108. let fprint = output_string
  109. and print = print_string
  110. ;;
  111.